Option Explicit
Sub Q_Sample018()
    'ոQ_Data01
    ']wޥζMicrosoft Scripting Runtime
    Dim myDic As Scripting.Dictionary
    Dim myRng As Range
    Dim myKeys As Variant
    Dim I As Long
    Set myDic = CreateObject("Scripting.Dictionary")
    'wƽd
    For Each myRng In Worksheets("Q_Data01").Range("a1") _
        .CurrentRegion.Columns(3).Offset(1).Cells
        With myRng
            If Len(.Text) > 0 Then
                myDic.Add Key:=myRng.Value, Item:=myRng.Offset(, 6).Value
            End If
        End With
    Next
    myKeys = myDic.Keys
    For I = LBound(myKeys) To UBound(myKeys)
        Debug.Print I, myKeys(I)
    Next
    Set myDic = Nothing                                  '
End Sub
